home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / runtime / runtime-utils.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  12.8 KB  |  504 lines  |  [TEXT/CCL2]

  1. ;;; runtime-utils.scm -- basic runtime support
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  9 Jun 1992
  5. ;;;
  6. ;;; This file contains definitions (beyond the normal mumble stuff)
  7. ;;; that is referenced directly in code built by the code generator.
  8. ;;; See backend/codegen.scm.
  9. ;;;
  10.  
  11. ;;; (delay form . maybe-name)
  12. ;;;   returns a delay object with unevaluated "form".
  13. ;;;   if name is  supplied, the thunk is defined as a named function --
  14. ;;;   this is strictly for debugging purposes.
  15.  
  16. (define-syntax (delay form . maybe-name)
  17.   `(cons '#f
  18.      ,(if (null? maybe-name)
  19.           `(lambda () ,form)
  20.           (let ((name  (car maybe-name)))
  21.         `(flet ((,name () ,form)) (function ,name)))
  22.         )))
  23.  
  24.  
  25. ;;; (box form)
  26. ;;;   returns a delay object with evaluated "form".
  27.  
  28. (define-syntax (box form)
  29.   (cond ((number? form)
  30.      `(quote ,(cons '#t form)))
  31.     ((and (pair? form) (eq? (car form) 'quote))
  32.      `(quote ,(cons '#t (cadr form))))
  33.     (else
  34.      `(cons '#t ,form))))
  35.  
  36. (define-syntax (unbox form)
  37.   `(cdr ,form))
  38.  
  39. (define-syntax (forced? form)
  40.   `(car ,form))
  41.  
  42.  
  43. ;;; (force delay)
  44. ;;;   return the value of the delay object.
  45.  
  46. (define (force delay-object)
  47.   (declare (type pair delay-object))
  48.   (if (car delay-object)
  49.       (cdr delay-object)
  50.       (begin
  51.         (let ((result  (funcall (cdr delay-object))))
  52.       (setf (car delay-object) '#t)
  53.       (setf (cdr delay-object) result)))))
  54.  
  55. ;;; Inline version of the above.  Not good to use everywhere because
  56. ;;; of code bloat problems, but handy for helper functions.
  57.  
  58. (define-syntax (force-inline delay-object)
  59.   (let ((temp1  (gensym))
  60.     (temp2  (gensym)))
  61.     `(let ((,temp1  ,delay-object))
  62.        (declare (type pair ,temp1))
  63.        (if (car ,temp1)
  64.        (cdr ,temp1)
  65.        (let ((,temp2  (funcall (cdr ,temp1))))
  66.          (setf (car ,temp1) '#t)
  67.          (setf (cdr ,temp1) ,temp2))))))
  68.  
  69.  
  70. ;;; (make-curried-fn opt-fn strictness)
  71. ;;; The basic idea is to compare the number of arguments received against
  72. ;;; the number expected.
  73. ;;; If the same, call the optimized entry point opt-fn.
  74. ;;; If more, apply the result of calling the optimized entry to the
  75. ;;;   leftover arguments.
  76. ;;; If less, make a closure that accepts the additional arguments.
  77.  
  78. (define (make-curried-fn opt-fn strictness)
  79.   (lambda args
  80.     (curried-fn-body '() args opt-fn strictness)))
  81.  
  82. (define (curried-fn-body previous-args args opt-fn strictness)
  83.   (multiple-value-bind
  84.       (saturated? actual-args leftover-args leftover-strictness)
  85.       (process-curried-fn-args strictness args '())
  86.     (setf actual-args (append previous-args actual-args))
  87.     (if saturated?
  88.     (if (null? leftover-args)
  89.         (apply opt-fn actual-args)
  90.         (apply (apply opt-fn actual-args) leftover-args))
  91.     (lambda more-args
  92.       (curried-fn-body actual-args more-args opt-fn leftover-strictness)))
  93.     ))
  94.  
  95. (define (process-curried-fn-args strictness args actual-args)
  96.   (cond ((null? strictness)
  97.      ;; At least as many arguments as expected.
  98.      (values '#t (nreverse actual-args) args strictness))
  99.     ((null? args)
  100.      ;; Not enough arguments supplied.
  101.        (values '#f (nreverse actual-args) args strictness))
  102.     (else
  103.      ;; Process the next argument.
  104.      (if (car strictness)
  105.          (push (force-inline (car args)) actual-args)
  106.          (push (car args) actual-args))
  107.       (process-curried-fn-args (cdr strictness) (cdr args) actual-args))
  108.     ))
  109.  
  110.  
  111. ;;; Special cases of the above.
  112.  
  113. (define (make-curried-fn-1-strict opt-fn)
  114.   (lambda (arg1 . moreargs)
  115.     (setf arg1 (force-inline arg1))
  116.     (if (null? moreargs)
  117.     (funcall opt-fn arg1)
  118.     (apply (funcall opt-fn arg1) moreargs))))
  119.  
  120. (define (make-curried-fn-1-nonstrict opt-fn)
  121.   (lambda (arg1 . moreargs)
  122.     (if (null? moreargs)
  123.     (funcall opt-fn arg1)
  124.     (apply (funcall opt-fn arg1) moreargs))))
  125.  
  126.  
  127. ;;; Special case for curried version of cons constructor
  128.  
  129. (define (cons-constructor arg1 . more-args)
  130.   (cond ((null? more-args)
  131.      (lambda still-more-args
  132.        (apply (function cons-constructor) arg1 still-more-args)))
  133.     ((null? (cdr more-args))
  134.      (cons arg1 (car more-args)))
  135.     (else
  136.      (error "Too many arguments to cons constructor!"))))
  137.  
  138.  
  139.  
  140. ;;; (make-tuple-constructor arity)
  141. ;;; Make uncurried function to build a constructor.
  142.  
  143. (define (make-tuple-constructor arity strictness)
  144.   (declare (type fixnum arity))
  145.   (cond ((eqv? arity 0)
  146.      ;; Actually, should never happen -- this is the unit constructor
  147.      0)
  148.     ((eqv? arity 1)
  149.      (if (car strictness)
  150.          (make-curried-fn-1-strict (function identity))
  151.          (make-curried-fn-1-nonstrict (function identity))))
  152.     ((eqv? arity 2)
  153.      (make-curried-fn (function cons) strictness))
  154.     (else
  155.      (make-curried-fn (function vector) strictness))))
  156.  
  157.  
  158. ;;; (make-tuple . args)
  159. ;;;   first-class version of the above
  160.  
  161. (define-syntax (make-tuple . args)
  162.   (let ((arity  (length args)))
  163.     (cond ((eqv? arity 0)
  164.        ;; Actually, should never happen -- this is the unit constructor
  165.        0)
  166.       ((eqv? arity 1)
  167.        (car args))
  168.       ((eqv? arity 2)
  169.        `(cons ,@args))
  170.       (else
  171.        `(vector ,@args)))))
  172.  
  173.  
  174. ;;; (make-tagged-data-constructor n arity)
  175. ;;;   build a function that makes a data structure with tag "n" and
  176. ;;;   "arity" slots.
  177.  
  178. (define (make-tagged-data-constructor n arity strictness)
  179.   (cond ((eqv? arity 0)
  180.      (vector n))
  181.     ((eqv? arity 1)
  182.      (if (car strictness)
  183.          (make-curried-fn-1-strict
  184.            (lambda (x) (vector n x)))
  185.          (make-curried-fn-1-nonstrict
  186.            (lambda (x) (vector n x)))))
  187.     (else
  188.      (make-curried-fn
  189.        (lambda args
  190.          (apply (function vector) n args))
  191.        strictness))))
  192.  
  193.  
  194. ;;; (make-tagged-data n . args)
  195. ;;;   first-class version of the above
  196.  
  197. (define-syntax (make-tagged-data n . args)
  198.   `(vector ,n ,@args))
  199.  
  200.  
  201. ;;; (tuple-select arity i object)
  202. ;;;   extract component "i" from untagged "object"
  203.  
  204. (define-syntax (tuple-select arity i object)
  205.   (cond ((eqv? arity 1)
  206.      object)
  207.     ((eqv? arity 2)
  208.      (if (eqv? i 0)
  209.          `(car ,object)
  210.          `(cdr ,object)))
  211.     (else
  212.      `(vector-ref (the vector ,object) (the fixnum ,i)))))
  213.  
  214.  
  215. ;;; (tagged-data-select arity i object)
  216. ;;;   extract component "i" from tagged "object"
  217.  
  218. (define-syntax (tagged-data-select arity i object)
  219.   (declare (ignore arity))
  220.   `(vector-ref (the vector ,object) (the fixnum ,(1+ i))))
  221.  
  222.  
  223.  
  224. ;;; Forced equivalents of the above.
  225.  
  226. (define (force-car x)
  227.   (force-inline (car x)))
  228.  
  229. (define (force-cdr x)
  230.   (force-inline (cdr x)))
  231.  
  232. (define (force-vector-ref x i)
  233.   (force-inline (vector-ref (the vector x) (the fixnum i))))
  234.  
  235. (define-syntax (force-tuple-select arity i object)
  236.   (cond ((eqv? arity 1)
  237.      `(force ,object))
  238.     ((eqv? arity 2)
  239.      (if (eqv? i 0)
  240.          `(force-car ,object)
  241.          `(force-cdr ,object)))
  242.     (else
  243.      `(force-vector-ref ,object ,i))))
  244.  
  245. (define-syntax (force-tagged-data-select arity i object)
  246.   (declare (ignore arity))
  247.   `(force-vector-ref ,object ,(1+ i)))
  248.  
  249.  
  250. (define (car/force x)
  251.   (car (force-inline x)))
  252.  
  253. (define (cdr/force x)
  254.   (cdr (force-inline x)))
  255.  
  256. (define (vector-ref/force x i)
  257.   (vector-ref (the vector (force-inline x)) i))
  258.  
  259. (define-syntax (tuple-select/force arity i object)
  260.   (cond ((eqv? arity 1)
  261.      `(force ,object))
  262.     ((eqv? arity 2)
  263.      (if (eqv? i 0)
  264.          `(car/force ,object)
  265.          `(cdr/force ,object)))
  266.     (else
  267.      `(vector-ref/force ,object ,i))))
  268.  
  269. (define-syntax (tagged-data-select/force arity i object)
  270.   (declare (ignore arity))
  271.   `(vector-ref/force ,object ,(1+ i)))
  272.  
  273.  
  274.  
  275. (define (force-car/force x)
  276.   (force-inline (car (force-inline x))))
  277.  
  278. (define (force-cdr/force x)
  279.   (force-inline (cdr (force-inline x))))
  280.  
  281. (define (force-vector-ref/force x i)
  282.   (force-inline (vector-ref (the vector (force-inline x)) i)))
  283.  
  284. (define-syntax (force-tuple-select/force arity i object)
  285.   (cond ((eqv? arity 1)
  286.      `(force (force ,object)))
  287.     ((eqv? arity 2)
  288.      (if (eqv? i 0)
  289.          `(force-car/force ,object)
  290.          `(force-cdr/force ,object)))
  291.     (else
  292.      `(force-vector-ref/force ,object ,i))))
  293.  
  294. (define-syntax (force-tagged-data-select/force arity i object)
  295.   (declare (ignore arity))
  296.   `(force-vector-ref/force ,object ,(1+ i)))
  297.  
  298.  
  299.  
  300.  
  301.  
  302. ;;; (constructor-number object)
  303. ;;;   return the tag from "object"
  304.  
  305. (define-syntax (constructor-number object)
  306.   `(vector-ref (the vector ,object) 0))
  307.  
  308.  
  309.  
  310. ;;; (funcall/force fn . args)
  311. ;;;   == (funcall (force fn) . args)
  312.  
  313. (define-syntax (funcall/force fn . args)
  314.   (let* ((n    (length args))
  315.      (junk (assv n '((1 . funcall/force-1)
  316.              (2 . funcall/force-2)
  317.              (3 . funcall/force-3)
  318.              (4 . funcall/force-4)))))
  319.     `(,(if junk (cdr junk) 'funcall/force-n) ,fn ,@args)))
  320.  
  321. (define (funcall/force-1 fn a1)
  322.   (funcall (force-inline fn) a1))
  323. (define (funcall/force-2 fn a1 a2)
  324.   (funcall (force-inline fn) a1 a2))
  325. (define (funcall/force-3 fn a1 a2 a3)
  326.   (funcall (force-inline fn) a1 a2 a3))
  327. (define (funcall/force-4 fn a1 a2 a3 a4)
  328.   (funcall (force-inline fn) a1 a2 a3 a4))
  329. (define-syntax (funcall/force-n fn . args)
  330.   `(funcall (force ,fn) ,@args))
  331.  
  332.  
  333. ;;; (delay-funcall fn . args)
  334. ;;;   == (delay (funcall fn . args))
  335.  
  336. (define-syntax (delay-funcall fn . args)
  337.   (let* ((n     (length args))
  338.      (junk  (assv n '((1 . delay-funcall-1)
  339.               (2 . delay-funcall-2)
  340.               (3 . delay-funcall-3)
  341.               (4 . delay-funcall-4)))))
  342.     `(,(if junk (cdr junk) 'delay-funcall-n) ,fn ,@args)))
  343.  
  344. (define (delay-funcall-1 fn a1)
  345.   (delay (funcall fn a1)))
  346.  
  347. (define (delay-funcall-2 fn a1 a2)
  348.   (delay (funcall fn a1 a2)))
  349.  
  350. (define (delay-funcall-3 fn a1 a2 a3)
  351.   (delay (funcall fn a1 a2 a3)))
  352.  
  353. (define (delay-funcall-4 fn a1 a2 a3 a4)
  354.   (delay (funcall fn a1 a2 a3 a4)))
  355.  
  356. (define (delay-funcall-n fn . args)
  357.   (delay (apply fn args)))
  358.  
  359.  
  360. ;;; (delay-funcall/force fn . args)
  361. ;;;   == (delay (funcall (force fn) . args))
  362.  
  363. (define-syntax (delay-funcall/force fn . args)
  364.   (let* ((n     (length args))
  365.      (junk  (assv n '((1 . delay-funcall/force-1)
  366.               (2 . delay-funcall/force-2)
  367.               (3 . delay-funcall/force-3)
  368.               (4 . delay-funcall/force-4)))))
  369.     `(,(if junk (cdr junk) 'delay-funcall/force-n) ,fn ,@args)))
  370.  
  371. (define (delay-funcall/force-1 fn a1)
  372.   (delay (funcall (force-inline fn) a1)))
  373.  
  374. (define (delay-funcall/force-2 fn a1 a2)
  375.   (delay (funcall (force-inline fn) a1 a2)))
  376.  
  377. (define (delay-funcall/force-3 fn a1 a2 a3)
  378.   (delay (funcall (force-inline fn) a1 a2 a3)))
  379.  
  380. (define (delay-funcall/force-4 fn a1 a2 a3 a4)
  381.   (delay (funcall (force-inline fn) a1 a2 a3 a4)))
  382.  
  383. (define (delay-funcall/force-n fn . args)
  384.   (delay (apply (force-inline fn) args)))
  385.  
  386.  
  387.  
  388. ;;; (make-haskell-string string)
  389. ;;;   Converts a Lisp string lazily to a boxed haskell string (makes
  390. ;;;   a delay with a magic function).  Returns an unboxed result.
  391.  
  392. (define (make-haskell-string string)
  393.   (declare (type string string))
  394.   (let ((index   1)
  395.     (size    (string-length string)))
  396.     (declare (type fixnum index size))
  397.     (cond ((eqv? size 0)
  398.        '())
  399.       ((eqv? size 1)
  400.        (cons (box (char->integer (string-ref string 0)))
  401.          (box '())))
  402.       (else
  403.        (letrec ((next-fn
  404.               (lambda ()
  405.             (let ((ch  (char->integer (string-ref string index))))
  406.               (incf index)
  407.               (cons (box ch)
  408.                 (if (eqv? index size)
  409.                     (box '())
  410.                     (cons '#f next-fn)))))))
  411.          (cons (box (char->integer (string-ref string 0)))
  412.            (cons '#f next-fn))))
  413.       )))
  414.  
  415.  
  416. ;;; Similar, but accepts an arbitrary tail (which must be a delay object)
  417.  
  418. (define (make-haskell-string-tail string tail-delay)
  419.   (declare (type string string))
  420.   (let ((index   1)
  421.     (size    (string-length string)))
  422.     (declare (type fixnum index size))
  423.     (cond ((eqv? size 0)
  424.        (force-inline tail-delay))
  425.       ((eqv? size 1)
  426.        (cons (box (char->integer (string-ref string 0)))
  427.          tail-delay))
  428.       (else
  429.        (letrec ((next-fn
  430.               (lambda ()
  431.             (let ((ch  (char->integer (string-ref string index))))
  432.               (incf index)
  433.               (cons (box ch)
  434.                 (if (eqv? index size)
  435.                     tail-delay
  436.                     (cons '#f next-fn)))))))
  437.          (cons (box (char->integer (string-ref string 0)))
  438.            (cons '#f next-fn))))
  439.       )))
  440.  
  441.  
  442. (define (haskell-string->string s)
  443.   (let ((length  0))
  444.     (declare (type fixnum length))
  445.     (do ((s s (force (cdr s))))
  446.     ((null? s))
  447.     (setf length (+ length 1)))
  448.     (let ((result  (make-string length)))
  449.       (declare (type string result))
  450.       (do ((s s (unbox (cdr s)))
  451.        (i 0 (+ i 1)))
  452.       ((null? s))
  453.       (declare (type fixnum i))
  454.       (setf (string-ref result i) (integer->char (force (car s)))))
  455.       result)))
  456.  
  457.  
  458. (define (print-haskell-string s port)
  459.    (do ((s1 s (force (cdr s1))))
  460.        ((null? s1))
  461.      (write-char (integer->char (force (car s1))) port)))
  462.  
  463. ;;; This explicates the value returned by a proc (the IO () type).
  464.  
  465. (define (insert-unit-value x)
  466.   (declare (ignore x))
  467.   0)
  468.  
  469. ;;; These handle list conversions
  470.  
  471. (define (haskell-list->list fn l)
  472.   (if (null? l)
  473.       '()
  474.       (cons (funcall fn (force (car l))) 
  475.         (haskell-list->list fn (force (cdr l))))))
  476.  
  477. (define (list->haskell-list fn l)
  478.   (if (null? l)
  479.       '()
  480.       (cons (box (funcall fn (car l)))
  481.         (box (list->haskell-list fn (cdr l))))))
  482.  
  483. (define (haskell-list->list/identity l)
  484.   (if (null? l)
  485.       '()
  486.       (cons (force (car l))
  487.         (haskell-list->list/identity (force (cdr l))))))
  488.  
  489. (define (list->haskell-list/identity l)
  490.   (if (null? l)
  491.       '()
  492.       (cons (box (car l))
  493.         (box (list->haskell-list/identity (cdr l))))))
  494.  
  495.  
  496.  
  497. ;;; Not currently needed
  498.  
  499. (define (eval-haskell-var v)
  500.   (let ((val (eval (fullname v))))
  501.     (if (var-strict? v)
  502.     val
  503.     (force val))))
  504.